home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 007 / xlisp2.arc / PT.LSP < prev    next >
Encoding:
Text File  |  1985-01-01  |  3.9 KB  |  175 lines
  1. ; This is a sample XLISP program.
  2. ; It implements a simple form of programmable turtle for VT100 compatible
  3. ; terminals.
  4.  
  5. ; To run it:
  6.  
  7. ;    A>xlisp pt
  8.  
  9. ; This should cause the screen to be cleared and two turtles to appear.
  10. ; They should each execute their simple programs and then the prompt
  11. ; should return.  Look at the code to see how all of this works.
  12.  
  13. ; Get some more memory
  14. (expand 1)
  15.  
  16. ; Clear the screen
  17. (defun clear ()
  18.     (princ "\e[H\e[J"))
  19.  
  20. ; Move the cursor
  21. (defun setpos (x y)
  22.     (princ "\e[") (princ y) (princ ";") (princ x) (princ "H"))
  23.  
  24. ; Kill the remainder of the line
  25. (defun kill ()
  26.     (princ "\e[K"))
  27.  
  28. ; Move the cursor to the currently set bottom position and clear the line
  29. ;  under it
  30. (defun bottom ()
  31.     (setpos bx (+ by 1))
  32.     (kill)
  33.     (setpos bx by)
  34.     (kill))
  35.  
  36. ; Clear the screen and go to the bottom
  37. (defun cb ()
  38.     (clear)
  39.     (bottom))
  40.  
  41.  
  42. ; ::::::::::::
  43. ; :: Turtle ::
  44. ; ::::::::::::
  45.  
  46. ; Define "Turtle" class
  47. (setq Turtle (Class 'new))
  48.  
  49. ; Define instance variables
  50. (Turtle 'ivars '(xpos ypos char))
  51.  
  52. ; Answer "isnew" by initing a position and char and displaying.
  53. (Turtle 'answer 'isnew '() '(
  54.     (setq xpos (setq newx (+ newx 1)))
  55.     (setq ypos 12)
  56.     (setq char "*")
  57.     (self 'display)
  58.     self))
  59.  
  60. ; Message "display" prints its char at its current position
  61. (Turtle 'answer 'display '() '(
  62.     (setpos xpos ypos)
  63.     (princ char)
  64.     (bottom)
  65.     self))
  66.  
  67. ; Message "char" sets char to its arg and displays it
  68. (Turtle 'answer 'char '(c) '(
  69.     (setq char c)
  70.     (self 'display)))
  71.  
  72. ; Message "goto" goes to a new place after clearing old one
  73. (Turtle 'answer 'goto '(x y) '(
  74.     (setpos xpos ypos) (princ " ")
  75.     (setq xpos x)
  76.     (setq ypos y)
  77.     (self 'display)))
  78.  
  79. ; Message "up" moves up if not at top
  80. (Turtle 'answer 'up '() '(
  81.     (if (> ypos 0)
  82.     (self 'goto xpos (- ypos 1))
  83.     (bottom))))
  84.  
  85. ; Message "down" moves down if not at bottom
  86. (Turtle 'answer 'down '() '(
  87.     (if (< ypos by)
  88.     (self 'goto xpos (+ ypos 1))
  89.     (bottom))))
  90.  
  91. ; Message "right" moves right if not at right
  92. (Turtle 'answer 'right '() '(
  93.     (if (< xpos 80)
  94.     (self 'goto (+ xpos 1) ypos)
  95.     (bottom))))
  96.  
  97. ; Message "left" moves left if not at left
  98. (Turtle 'answer 'left '() '(
  99.     (if (> xpos 0)
  100.     (self 'goto (- xpos 1) ypos)
  101.     (bottom))))
  102.  
  103.  
  104. ; :::::::::::::
  105. ; :: PTurtle ::
  106. ; :::::::::::::
  107.  
  108. ; Define "DPurtle" programable turtle class
  109. (setq PTurtle (Class 'new Turtle))
  110.  
  111. ; Define instance variables
  112. (PTurtle 'ivars '(prog pc))
  113.  
  114. ; Message "program" stores a program
  115. (PTurtle 'answer 'program '(p) '(
  116.     (setq prog p)
  117.     (setq pc prog)
  118.     self))
  119.  
  120. ; Message "step" executes a single program step
  121. (PTurtle 'answer 'step '() '(
  122.     (if (null pc)
  123.     (setq pc prog))
  124.     (if pc
  125.     (progn (self (car pc))
  126.            (setq pc (cdr pc))))
  127.     self))
  128.  
  129. ; Message "step:" steps each turtle program n times
  130. (PTurtle 'answer 'step: '(n) '(
  131.     (dotimes (x n) (self 'step))
  132.     self))
  133.  
  134.  
  135. ; ::::::::::::::
  136. ; :: PTurtles ::
  137. ; ::::::::::::::
  138.  
  139. ; Define "PTurtles" class
  140. (setq PTurtles (Class 'new))
  141.  
  142. ; Define instance variables
  143. (PTurtles 'ivars '(turtles))
  144.  
  145. ; Message "make" makes a programable turtle and adds it to the collection
  146. (PTurtles 'answer 'make '(x y &aux newturtle) '(
  147.     (setq newturtle (PTurtle 'new))
  148.     (newturtle 'goto x y)
  149.     (setq turtles (cons newturtle turtles))
  150.     newturtle))
  151.  
  152. ; Message "step" steps each turtle program once
  153. (PTurtles 'answer 'step '() '(
  154.     (mapcar '(lambda (turtle) (turtle 'step)) turtles)
  155.     self))
  156.  
  157. ; Message "step:" steps each turtle program n times
  158. (PTurtles 'answer 'step: '(n) '(
  159.     (dotimes (x n) (self 'step))
  160.     self))
  161.  
  162.  
  163. ; Initialize things and start up
  164. (setq bx 0)
  165. (setq by 20)
  166. (setq newx 0)
  167.  
  168. ; Create some programmable turtles
  169. (cb)
  170. (setq turtles (PTurtles 'new))
  171. (setq t1 (turtles 'make 40 10))
  172. (setq t2 (turtles 'make 41 10))
  173. (t1 'program '(left right up down))
  174. (t2 'program '(right left down up))
  175.